{-# OPTIONS_GHC -XRecordWildCards -XNamedFieldPuns #-}
module ProxyWSDL {-(gen_proxy)-} where

import Types
import Data.List
import Data.Char
import Text.XML.Light.Types()

aliasToElName :: WsElem -> String -> String
aliasToElName (WsElem {wselName, wselAlias}) name = lowerFirst $ if wselAlias == wselName then wselAlias ++ upperFirst name else wselAlias

genType :: WsType -> String
genType wsct 
    | isCT wsct =  let 
            up = upperFirst $ wsctAlias wsct
            me = map f $ wsctElems wsct
        in
        "data " ++ up  ++ "__ = " ++ up ++ "__ {\n" ++ unlines (init me ++ [init $ last me]) ++ "} deriving (Typeable, Eq) \n"
    | otherwise = ""
    where 
        f e@(WsElem {wselNillable, wselMaxOccurs, wselType}) = replicate 4 ' '
            ++ aliasToElName e (wsctName wsct) ++ " :: "
            ++ (if wselNillable then "Maybe " else "")
            ++ (if wselMaxOccurs == Unbounded then "[" else "")
            ++ case wselType of
                WsSimpleType "string" -> "String"
                WsSimpleType "boolean" -> "Bool"
                WsSimpleType "dateTime" -> "LocalTime"
                wsct' -> if isCT wsct' then (if wsctPrefix wsct' == wsctPrefix wsct then "" else ((++ ".") . upperFirst . wsctPrefix) wsct') ++ 
                                                upperFirst (wsctAlias wsct') ++ "__"
                        else error $ "Unknown type " ++ show wsct' ++ "in function \"genType -> f\"\n"
            ++ (if wselMaxOccurs == Unbounded then "]" else "") 
            ++ ","
            
genInstance :: WsType -> String

genInstance (WsSimpleType _) = ""

genInstance ct = 
    "\ninstance Xmlable " ++ ufName ++ " where" ++
    "\n\ttoContent x = [makeToContent " ++ els ++ " [" ++ ns' 2 (\e->", toContent." ++ aliasToElName e (wsctName ct)) ++ "] x]" ++
    "\n\tfromContent cs = " ++ ufName ++ " " ++ ns 2 ") (fromContent c" ++ ")" ++
    "\n\t\twhere [" ++ ns 2 ", c" ++ "] = forFromContent nss " ++ els ++ " cs"
    where
        ufName = upperFirst (wsctAlias ct) ++ "__"
        ns' n f = drop n . concatMap f . wsctElems $ ct
        ns n s = drop n . concat . zipWith (\n' _-> s ++ show n') [(1::Integer)..] . wsctElems $ ct
        els = ("[" ++) . (++ "]") . drop 2 . concatMap (\(WsElem {wselName})->", \""++ wsctPrefix ct ++ ":" ++ wselName ++ "\"")
                . wsctElems $ ct

upperAfterDot :: String -> String
upperAfterDot s = zipWith (\a b -> if b `elem` "./" then toUpper a else a) s ('.':s)

genProxy :: WsDescr -> String -> [String]
genProxy WsDescr {wsdName, wsdSchemas, wsdOpers} package = map gen_module $ zip [(0::Integer)..] wsdSchemas
    where
        gen_module (num, WsSchema {..}) = unlines $ 
            [
                "{-# OPTIONS_GHC -XDeriveDataTypeable #-}", 
                "module " ++ (upperAfterDot . (package ++) . snd . getPrefName . snd . head $ wssNamespaces) ++ " where",
                imp "Data." [{- "List", "Maybe", -}"Typeable", "Time.LocalTime"],
                imp "WS.Runtime." ("Xmlable" : ["Main" | num == 0]),
                imp "qualified " . map (\(p,n) -> (++ upperFirst p) . (++ " as ") . 
                        upperAfterDot . (package ++) . snd . getPrefName $ n) . drop 1 $ wssNamespaces
            ] ++
            [
                "nss :: [(String, String)]",
                "nss = " ++ show wssNamespaces
            ] 
            ++
            [x | x <- [
                    "ws :: String",
                    "ws = " ++ show wsdName,
                    "-- operations",
                    "",
                    unlines (map showOper wsdOpers),
                    ""
                ], num == 0] ++
            [
                "-- types definition\n",
                unlines (map genType wssTypes), 
                "",
                "-- instances",
                "",
                unlines (map genInstance wssTypes)
            ]
            where
                imp pref = concatMap ((("import " ++ pref) ++) . (++"\n"))
                showOper (WsOper {..}) = lf ++ " :: WsParams -> " ++ type_name wsopInput ++ " -> IO " ++ type_name wsopOutput ++ "\n" ++ 
                            lf ++ " = runService ws nss \"tns:" ++ wsopName ++ "\""
                    where
                        lf = lowerFirst wsopName
                        -- uf = upperFirst wsopName
                        type_name (WsComplexType {wsctName}) = upperFirst wsctName ++ "__"
                        type_name (WsSimpleType s) = s

{-------------------------------------------
data WsProxy  = WsProxy {
        wspWs       :: String,
        wspNamespace    :: (String, String),
        wspOps      :: [WspOpDef],
        wspSchemas  :: [WspSchema]
    }
data WspOpDef = WspOpDef {
        wodName     :: String,
        wodInput    :: WspTypeDef,
        wodOutput   :: WspTypeDef
    }
data WspSchema = WspSchema {
        wspsNss :: [(String, String)],
        wspsTypes :: [WspTypeDef]
    }
data WspTypeDef = WspTypeDef {
        wtdType     :: WsType,
        wtdDepend   :: [(String, String)]   -- (qualified name, module)
    }

gen_ws_proxy :: WsDescr -> WsProxy
gen_ws_proxy (WsDescr {..}) = WsProxy {
        wspWs = wsdName,
        wspNamespace = head wsdNamespaces,
        wspOps = ops,
        wspSchemas = schemas
        --, wspTypes = types
    }
    where
        ops = map (\(WsOper {..}) -> WspOpDef {
                wodName = wsopName,
                wodInput = WspTypeDef {
                        wtdType = wsopInput,
                        wtdDepend = error "wtdDepend is not used for WspOpDef.wodInput/wodOutput"  -- not used
                    },
                wodOutput = WspTypeDef {
                        wtdType = wsopOutput,
                        wtdNss = take 1 wsdNamespaces
                        wtdDepend = error "wtdDepend is not used for WspOpDef.wodInput/wodOutput"  -- not used
                    }
            }) wsdOpers
        schemas = map (\(WsSchema {..}) -> WspSchema {
                wspsNss = wsdNamespaces,
                wspsTypes = types
            }) wsdSchemas
            where
                types = map (\wst@(WsType {..}) -> WspTypeDef {
                        wtdType = wst,
                        wtdDepend = 
                    }) wssTypes
            
-------------------------------------------}
